home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gnat1792.zip / gnat179b / t-adainc / s-tatise.adb < prev    next >
Text File  |  1994-05-19  |  21KB  |  648 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                 GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS               --
  4. --                                                                          --
  5. --             S Y S T E M . T A S K _ T I M E R _ S E R V I C E            --
  6. --                                                                          --
  7. --                                  B o d y                                 --
  8. --                                                                          --
  9. --                             $Revision: 1.7 $                             --
  10. --                                                                          --
  11. --           Copyright (c) 1991,1992,1993, FSU, All Rights Reserved         --
  12. --                                                                          --
  13. --  GNARL is free software; you can redistribute it and/or modify it  under --
  14. --  terms  of  the  GNU  Library General Public License as published by the --
  15. --  Free Software Foundation; either version 2, or  (at  your  option)  any --
  16. --  later  version.   GNARL is distributed in the hope that it will be use- --
  17. --  ful, but but WITHOUT ANY WARRANTY; without even the implied warranty of --
  18. --  MERCHANTABILITY  or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Gen- --
  19. --  eral Library Public License for more details.  You should have received --
  20. --  a  copy of the GNU Library General Public License along with GNARL; see --
  21. --  file COPYING. If not, write to the Free Software Foundation,  675  Mass --
  22. --  Ave, Cambridge, MA 02139, USA.                                          --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25.  
  26. with Ada.Calendar.Conv;
  27. with System.Compiler_Exceptions;
  28. with System.Real_Time.Conv;
  29. with System.Task_Primitives;
  30. with System.Tasking.Stages;
  31. with System.Task_Clock.Machine_Specifics;
  32. with Unchecked_Conversion;
  33.  
  34. package body System.Task_Timer_Service is
  35.  
  36.    use System.Tasking.Protected_Objects;
  37.    use System.Tasking;
  38.  
  39.    use System.Task_Clock;
  40.    --  Included use clause for comparison operators
  41.  
  42.    function Clock return Stimespec
  43.      renames Task_Clock.Machine_Specifics.Clock;
  44.  
  45.    type Q_Rec;
  46.    type Q_Link is access Q_Rec;
  47.  
  48.    type Q_Rec is record
  49.       S_O      : Signal_Object.O_Type;
  50.       T        : Task_Clock.Stimespec;    --  wake up time
  51.       Next     : Q_Link;
  52.       Previous : Q_Link;
  53.    end record;
  54.  
  55.    Q_Head : Q_Link := null;
  56.  
  57.  
  58.    Timer_Condition :  Task_Primitives.Condition_Variable;
  59.    Timer_Lock      :  Task_Primitives.Lock;
  60.  
  61. --  Hand Traslated code will be provided here. ???
  62.  
  63.    function To_Access is new
  64.      Unchecked_Conversion (System.Address, Protection_Access);
  65.  
  66.    -------------------
  67.    -- Signal_Object --
  68.    -------------------
  69.  
  70.    package body Signal_Object is
  71.  
  72.       --------------------------------------
  73.       -- Signal_Object.Signal_Unprotected --
  74.       --------------------------------------
  75.  
  76.       procedure Signal_Unprotected (Open : in out boolean) is
  77.       begin
  78.          Open := true;
  79.       end Signal_Unprotected;
  80.  
  81.       procedure Signal (PO : in out O_Type) is
  82.          PS : Boolean;
  83.  
  84.       begin
  85.          Tasking.Protected_Objects.Lock (To_Access (PO.Object'Address));
  86.  
  87.          begin
  88.             Signal_Unprotected (PO.Open);
  89.  
  90.          exception
  91.             when others =>
  92.                Service_Entries (PO, PS);
  93.                Tasking.Protected_Objects.Unlock (
  94.                      To_Access (PO.Object'Address));
  95.                raise;
  96.          end;
  97.  
  98.          Service_Entries (PO, PS);
  99.  
  100.          --  Barriers may have changed
  101.  
  102.          Tasking.Protected_Objects.Unlock (To_Access (PO.Object'Address));
  103.       end Signal;
  104.  
  105.       ------------------------------------------
  106.       -- Signal_Object.Wait_Count_Unprotected --
  107.       ------------------------------------------
  108.  
  109.       function Wait_Count_Unprotected (Object : Protection) return integer is
  110.       begin
  111.          --  Find the number of calls waiting on the specified entry
  112.  
  113.          return Protected_Count (Object, 1);
  114.       end Wait_Count_Unprotected;
  115.  
  116.       ------------------------------
  117.       -- Signal_Object.Wait_Count --
  118.       ------------------------------
  119.  
  120.       procedure Wait_Count (PO : in out O_Type; W : out integer) is
  121.       begin
  122.          Tasking.Protected_Objects.Lock_Read_Only
  123.            (To_Access (PO.Object'Address));
  124.  
  125.          W := Wait_Count_Unprotected (PO.Object);
  126.          Tasking.Protected_Objects.Unlock (To_Access (PO.Object'Address));
  127.  
  128.       exception
  129.          when others =>
  130.             Tasking.Protected_Objects.Unlock (To_Access (PO.Object'Address));
  131.             raise;
  132.       end Wait_Count;
  133.  
  134.       -----------------------------------
  135.       -- Signal_Object.Service_Entries --
  136.       -----------------------------------
  137.  
  138.       procedure Service_Entries
  139.         (PO               : in out O_Type;
  140.          Pending_Serviced : out Boolean)
  141.       is
  142.          subtype PO_Entry_Index is Protected_Entry_Index
  143.            range Null_Protected_Entry .. 1;
  144.  
  145.          P             : System.Address;
  146.          Barriers      : Tasking.Barrier_Vector (1 .. 1);
  147.          E             : PO_Entry_Index;
  148.          PS            : Boolean;
  149.          Cumulative_PS : Boolean := False;
  150.  
  151.       begin
  152.          loop
  153.             begin
  154.                Barriers (1) := PO.Open;
  155.  
  156.             exception
  157.                when others =>
  158.                   begin
  159.                      Tasking.Protected_Objects.Broadcast_Program_Error
  160.                        (To_Access (PO.Object'Address));
  161.  
  162.                   exception
  163.                      when Program_Error =>
  164.                         Tasking.Protected_Objects.Unlock
  165.                           (To_Access (PO.Object'Address));
  166.                         raise;
  167.                   end;
  168.             end;
  169.  
  170.             Tasking.Protected_Objects.Next_Entry_Call
  171.               (To_Access (PO.Object'Address), Barriers, P, E);
  172.  
  173.             begin
  174.                case E is
  175.  
  176.                   when Null_Protected_Entry =>
  177.  
  178.                      --  No pending call to serve
  179.  
  180.                      exit;
  181.  
  182.                   when 1 =>
  183.  
  184.                      --  Code from the entry Wait
  185.  
  186.                      PO.Open := False;
  187.                      Tasking.Protected_Objects.Complete_Entry_Body
  188.                        (To_Access (PO.Object'Address), PS);
  189.                end case;
  190.  
  191.             exception
  192.                when others =>
  193.                   Tasking.Protected_Objects.Exceptional_Complete_Entry_Body (
  194.                     Object => To_Access (PO.Object'Address),
  195.                     Ex => Compiler_Exceptions.Current_Exception,
  196.                     Pending_Serviced => PS);
  197.             end;
  198.  
  199.             Cumulative_PS := Cumulative_PS or PS;
  200.          end loop;
  201.  
  202.          Pending_Serviced := Cumulative_PS;
  203.       end Service_Entries;
  204.  
  205.    end Signal_Object;
  206.  
  207.    -----------
  208.    -- Timer --
  209.    -----------
  210.  
  211.    package body Timer is
  212.  
  213.       -------------------------------
  214.       -- Timer.Service_Unprotected --
  215.       -------------------------------
  216.  
  217.       procedure Service_Unprotected (T : out Task_Clock.Stimespec) is
  218.          Q_Ptr : Q_Link := Q_Head;
  219.          W     : integer;
  220.  
  221.       begin
  222.          while Q_Ptr /= null loop
  223.             Signal_Object.Wait_Count (Q_Ptr.S_O, W);
  224.  
  225.             if Q_Ptr.T < Clock or else W = 0 then
  226.  
  227.                --  Wake up the waiting task
  228.  
  229.                Signal_Object.Signal (Q_Ptr.S_O);
  230.  
  231.                --  When it is done, all the pending calls are serviced
  232.                --  Therefore it is safe to finalize it.
  233.  
  234.                Finalize_Protection (To_Access (Q_Ptr.S_O.Object'Address));
  235.  
  236.                --  Remove the entry, case of head entry
  237.  
  238.                if Q_Ptr = Q_Head then
  239.                   Q_Head := Q_Ptr.Next;
  240.  
  241.                   if Q_Head /= null then
  242.                      Q_Head.Previous := null;
  243.                   end if;
  244.  
  245.                --  Case of tail entry
  246.  
  247.                elsif Q_Ptr.Next = null then
  248.                   Q_Ptr.Previous.Next := null;
  249.  
  250.                --  Case of middle entry
  251.  
  252.